home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / tcsel003.zip / DIRDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1992-10-16  |  7KB  |  237 lines
  1. { DIRDEMO.PAS
  2.   Author: Trevor Carlsen. Released into the public domain 1989
  3.                           Last modification 1992.
  4.   Demonstrates in a very simple way how to display a directory in a screen
  5.   window and scroll backwards or forwards.  }
  6.  
  7. uses
  8.   dos,
  9.   crt,
  10.   keyinput;
  11.  
  12. type
  13.   str3    = string[3];
  14.   str6    = string[6];
  15.   str16   = string[16];
  16.   stype   = (_name,_ext,_date,_size);
  17.   DirRec  = record
  18.               name  : NameStr;
  19.               ext   : ExtStr;
  20.               size  : str6;
  21.               date  : str16;
  22.               Lsize,
  23.               Ldate : longint;
  24.               dir   : boolean;
  25.             end;
  26.  
  27. const
  28.   maxdir       = 1000;     { maximum number of directory entries }
  29.   months : array[1..12] of str3 =
  30.            ('Jan','Feb','Mar','Apr','May','Jun',
  31.             'Jul','Aug','Sep','Oct','Nov','Dec');
  32.   WinX1 = 14; WinX2 = 1;
  33.   WinY1 = 65; WinY2 = 23;
  34.   LtGrayOnBlue      = $17;
  35.   BlueOnLtGray      = $71;
  36.   page              = 22;
  37.   maxlines : word   = page;
  38.  
  39. type
  40.   DataArr           = array[1..maxdir] of DirRec;
  41.  
  42. var
  43.   DirEntry          : DataArr;
  44.   x, numb           : integer;
  45.   path              : DirStr;
  46.   key               : byte;
  47.   finished          : boolean;
  48.   OldAttr           : byte;
  49.  
  50. procedure quicksort(var s; left,right : word; SortType: stype);
  51.   var
  52.     data      : DataArr absolute s;
  53.     pivotStr,
  54.     tempStr   : string;
  55.     pivotLong,
  56.     tempLong  : longint;
  57.     lower,
  58.     upper,
  59.     middle    : word;
  60.  
  61.   procedure swap(var a,b);
  62.     var x : DirRec absolute a;
  63.         y : DirRec absolute b;
  64.         t : DirRec;
  65.     begin
  66.       t := x;
  67.       x := y;
  68.       y := t;
  69.     end;
  70.  
  71.   begin
  72.     lower := left;
  73.     upper := right;
  74.     middle:= (left + right) div 2;
  75.     case SortType of
  76.       _name: pivotStr   := data[middle].name;
  77.       _ext : pivotStr   := data[middle].ext;
  78.       _size: pivotLong  := data[middle].Lsize;
  79.       _date: pivotLong  := data[middle].Ldate;
  80.     end; { case SortType }
  81.     repeat
  82.       case SortType of
  83.         _name: begin
  84.                  while data[lower].name < pivotStr do inc(lower);
  85.                  while pivotStr < data[upper].name do dec(upper);
  86.                end;
  87.         _ext : begin
  88.                  while data[lower].ext < pivotStr do inc(lower);
  89.                  while pivotStr < data[upper].ext do dec(upper);
  90.                end;
  91.         _size: begin
  92.                  while data[lower].Lsize < pivotLong do inc(lower);
  93.                  while pivotLong < data[upper].Lsize do dec(upper);
  94.                end;
  95.         _date: begin
  96.                  while data[lower].Ldate < pivotLong do inc(lower);
  97.                  while pivotLong < data[upper].Ldate do dec(upper);
  98.                end;
  99.       end; { case SortType }
  100.       if lower <= upper then begin
  101.         swap(data[lower],data[upper]);
  102.         inc(lower);
  103.         dec(upper);
  104.        end;
  105.     until lower > upper;
  106.     if left < upper then quicksort(data,left,upper,SortType);
  107.     if lower < right then quicksort(data,lower,right,SortType);
  108.   end; { quicksort }
  109.  
  110. function form(st : string; len : byte): string;
  111.   { Replaces spaces in a numeric string with zeroes  }
  112.   var
  113.     x : byte ;
  114.   begin
  115.     form := st;
  116.     for x := 1 to len do
  117.       if st[x] = ' ' then
  118.         form[x] := '0'
  119.   end;
  120.  
  121. procedure ReadDir(var count : integer);
  122.   { Reads the current directory and places in the main array }
  123.   var
  124.     DirInfo    : SearchRec;
  125.  
  126.   procedure CreateRecord;
  127.     var
  128.       Dt : DateTime;
  129.       st : str6;
  130.     begin
  131.       with DirEntry[count] do begin
  132.         FSplit(DirInfo.name,path,name,ext);             { Split file name up }
  133.         if ext[1] = '.' then                                { get rid of dot }
  134.           ext := copy(ext,2,3);
  135.         name[0] := #8;  ext[0] := #3; { force to a set length for formatting }
  136.         Lsize := DirInfo.size;
  137.         Ldate := DirInfo.time;
  138.         str(DirInfo.size:6,size);
  139.         UnPackTime(DirInfo.time,Dt);
  140.         date := '';
  141.         str(Dt.day:2,st);
  142.         date := st + '-' + months[Dt.month] + '-';
  143.         str((Dt.year-1900):2,st);
  144.         date := date + st + #255#255;
  145.         str(Dt.hour:2,st);
  146.         date := date + st + ':';
  147.         str(Dt.Min:2,st);
  148.         date := date + st;
  149.         date := form(date,length(date));
  150.         dir := DirInfo.attr and Directory = Directory;
  151.       end; { with }
  152.     end; { CreateRecord }
  153.  
  154.   begin { ReadDir }
  155.     count := 0;         { for keeping a record of the number of entries read }
  156.     FillChar(DirEntry,sizeof(DirEntry),32);           { initialize the array }
  157.     FindFirst('*.*',Anyfile,DirInfo);
  158.     while (DosError = 0) and (count < maxdir) do begin
  159.       inc(count);
  160.       CreateRecord;
  161.       FindNext(DirInfo);
  162.     end; { while }
  163.     if count < page then
  164.       maxlines := count;
  165.     quicksort(DirEntry,1,count,_name);
  166.   end; { ReadDir }
  167.  
  168. procedure DisplayDirectory(n : integer);
  169.   var
  170.     x,y : integer;
  171.   begin
  172.     y := 1;
  173.     for x := n to n + maxlines do
  174.       with DirEntry[x] do begin
  175.         gotoxy(4,y);inc(y);
  176.         write(name,'  ');
  177.         write(ext,' ');
  178.         if dir then write('<DIR>')
  179.         else write('     ');
  180.         write(size:8,date:18);
  181.       end; { with }
  182.   end; { DisplayDirectory }
  183.  
  184. begin { main }
  185.   Clrscr;
  186.   gotoXY(5,24);
  187.   OldAttr  := TextAttr;
  188.   TextAttr := BlueOnLtGray;
  189.   write(' F1=Sort by name F2=Sort by extension F3=Sort by size F4=Sort by date ');
  190.   gotoXY(5,25);
  191.   write('   Use arrow keys to scroll through directory display - <ESC> quits   ');
  192.   TextAttr := LtGrayOnBlue;
  193.   window(WinX1,WinX2,WinY1,WinY2);  { make the window }
  194.   Clrscr;
  195.   HiddenCursor;
  196.   ReadDir(numb);
  197.   x := 1; finished := false;
  198.   repeat
  199.     DisplayDirectory(x); { display maxlines files }
  200.       case KeyWord of
  201.       F1 {name} : begin
  202.                     x := 1;
  203.                     quicksort(DirEntry,1,numb,_name);
  204.                   end;
  205.       F2 {ext}  : begin
  206.                     x := 1;
  207.                     quicksort(DirEntry,1,numb,_ext);
  208.                   end;
  209.       F3 {size} : begin
  210.                     x := 1;
  211.                     quicksort(DirEntry,1,numb,_size);
  212.                   end;
  213.       F4 {date} : begin
  214.                     x := 1;
  215.                     quicksort(DirEntry,1,numb,_date);
  216.                   end;
  217.       home      : x := 1;
  218.       EndKey    : x := numb - maxlines;
  219.       UpArrow   : if x > 1 then
  220.                     dec(x);
  221.       DownArrow : if x < (numb - maxlines) then
  222.                     inc(x);
  223.       PageDn    : if (x + page) > (numb - maxlines) then
  224.                     x := numb - maxlines
  225.                   else inc(x,page);
  226.       PageUp    : if (x - page) > 0 then
  227.                     dec(x,page)
  228.                   else x := 1;
  229.       escape    : finished := true
  230.       end; { case }
  231.   until finished;
  232.   NormalCursor;
  233.   TextAttr := OldAttr;
  234.   ClrScr;
  235. end.
  236.  
  237.